home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clx.lha / clx / debug / keytrans.l < prev    next >
Lisp/Scheme  |  1988-09-12  |  10KB  |  266 lines
  1. ;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
  2.  
  3. ;;; CLX keysym-translation test programs
  4.  
  5. ;;;
  6. ;;;             TEXAS INSTRUMENTS INCORPORATED
  7. ;;;                  P.O. BOX 2909
  8. ;;;                   AUSTIN, TEXAS 78769
  9. ;;;
  10. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  11. ;;;
  12. ;;; Permission is granted to any individual or institution to use, copy, modify,
  13. ;;; and distribute this software, provided that this complete copyright and
  14. ;;; permission notice is maintained, intact, in all copies and supporting
  15. ;;; documentation.
  16. ;;;
  17. ;;; Texas Instruments Incorporated provides this software "as is" without
  18. ;;; express or implied warranty.
  19. ;;;
  20.  
  21. (in-package 'xlib :use '(lisp))
  22.  
  23. (defun list-missing-keysyms ()
  24.   ;; Lists explorer characters which have no keysyms
  25.   (dotimes (i 256)
  26.     (unless (character->keysyms (int-char i))
  27.       (format t "~%(define-keysym ~@c ~d)" (int-char i) i))))
  28.  
  29. (defun list-multiple-keysyms ()
  30.   ;; Lists characters with more than one keysym
  31.   (dotimes (i 256)
  32.     (when (cdr (character->keysyms (int-char i)))
  33.       (format t "~%Character ~@c [~d] has keysyms" (int-char i) i)
  34.       (dolist (keysym (character->keysyms (int-char i)))
  35.     (format t "  ~d ~d" (ldb (byte 8 8) keysym) (ldb (byte 8 0) keysym))))))
  36.  
  37. (defun check-lowercase-keysyms ()
  38.   ;; Checks for keysyms with incorrect :lowercase parameters
  39.   (maphash #'(lambda (key mapping)
  40.            (let* ((value (car mapping))
  41.               (char (keysym-mapping-object value)))
  42.          (if (and (characterp char) (both-case-p char)
  43.               (= (char-int char) (char-int (char-upcase char))))
  44.              ;; uppercase alphabetic character
  45.              (unless (eq (keysym-mapping-lowercase value)
  46.                  (char-int (char-downcase char)))
  47.                (let ((lowercase (keysym-mapping-lowercase value))
  48.                  (should-be (char-downcase char)))
  49.              (format t "~%Error keysym ~3d ~3d (~@c) has :Lowercase ~3d ~3d (~s) Should be ~3d ~3d (~@c)"
  50.                  (ldb (byte 8 8) key)
  51.                  (ldb (byte 8 0) key)
  52.                  char
  53.                  (and lowercase (ldb (byte 8 8) lowercase))
  54.                  (and lowercase (ldb (byte 8 0) lowercase))
  55.                  (int-char lowercase)
  56.                  (ldb (byte 8 8) (char-int should-be))
  57.                  (ldb (byte 8 0) (char-int should-be))
  58.                  should-be)))
  59.            (when (keysym-mapping-lowercase value)
  60.              (let ((lowercase (keysym-mapping-lowercase value)))
  61.                (format t "~%Error keysym ~3d ~3d (~@c) has :lowercase ~3d ~3d (~@c) and shouldn't"
  62.                    (ldb (byte 8 8) key)
  63.                    (ldb (byte 8 0) key)
  64.                    char
  65.                    (and lowercase (ldb (byte 8 8) (char-int lowercase)))
  66.                    (and lowercase (ldb (byte 8 0) (char-int lowercase)))
  67.                    lowercase
  68.                    ))))))
  69.        *keysym->character-map*))
  70.  
  71. (defun print-all-keysyms ()
  72.   (let ((all nil))
  73.     (maphash #'(lambda (key value) (push (cons key value) all)) *keysym->character-map*)
  74.     (setq all (sort all #'< :key #'car))
  75.     (format t "~%~d keysyms:" (length all))
  76.     
  77.     (dolist (keysym all)
  78.       (format t "~%~3d ~3d~{ ~s~}"
  79.           (ldb (byte 8 8) (car keysym))
  80.           (ldb (byte 8 0) (car keysym))
  81.           (cadr keysym))
  82.       (dolist (mapping (cddr keysym))
  83.     (format t "~%~7@t~{ ~s~}" mapping)))))
  84.  
  85. (defun keysym-mappings (keysym &key display (mask-format #'identity))
  86.   ;; Return all the keysym mappings for keysym.
  87.   ;; Returns a list of argument lists that are argument-lists to define-keysym.
  88.   ;; The following will re-create the mappings for KEYSYM:
  89.   ;; (dolist (mapping (keysym-mappings) keysym)
  90.   ;;    (apply #'define-keysym mapping))
  91.   (let ((mappings (append (and display (cdr (assoc keysym (display-keysym-translation display))))
  92.               (gethash keysym *keysym->character-map*)))
  93.     (result nil))
  94.     (dolist (mapping mappings)
  95.       (let ((object (keysym-mapping-object mapping))
  96.         (translate (keysym-mapping-translate mapping))
  97.         (lowercase (keysym-mapping-lowercase mapping))
  98.         (modifiers (keysym-mapping-modifiers mapping))
  99.         (mask (keysym-mapping-mask mapping)))
  100.     (push (append (list object keysym)
  101.               (when translate (list :translate translate))
  102.               (when lowercase (list :lowercase lowercase))
  103.               (when modifiers (list :modifiers (funcall mask-format modifiers)))
  104.               (when mask (list :mask (funcall mask-format mask))))
  105.           result)))
  106.     (nreverse result)))
  107.  
  108. #+comment
  109. (defun print-keysym-mappings (keysym &optional display)
  110.     (format t "~%(keysym ~d ~3d) "
  111.         (ldb (byte 8 8) keysym)
  112.         (ldb (byte 8 0) keysym))
  113.   (dolist (mapping (keysym-mappings keysym :display display))
  114.     (format t "~16t~{ ~s~}~%" mapping)))
  115.  
  116. (defun print-keysym-mappings (keysym &optional display)
  117.   (flet ((format-mask (mask)
  118.               (cond ((numberp mask)
  119.                  `(make-state-mask ,@(make-state-keys mask)))
  120.                 ((atom mask) mask)
  121.                 (t `(list ,@(mapcar
  122.                       #'(lambda (item)
  123.                           (if (numberp item)
  124.                           `(keysym ,(keysym-mapping-object
  125.                                   (car (gethash item *keysym->character-map*))))
  126.                         item))
  127.                       mask))))))
  128.     (dolist (mapping (keysym-mappings keysym :display display :mask-format #'format-mask))
  129.       (format t "~%(define-keysym ~s (keysym ~d ~3d)~{ ~s~})"
  130.           (car mapping)
  131.           (ldb (byte 8 8) keysym)
  132.           (ldb (byte 8 0) keysym)
  133.           (cdr mapping)))))
  134.  
  135. (defun keysym-test (host)
  136.   ;; Server key-press Loop-back test
  137.   (let* ((display (open-display host))
  138.      (width 400)
  139.      (height 400)
  140.      (screen (display-default-screen display))
  141.      (black (screen-black-pixel screen))
  142.      (white (screen-white-pixel screen))
  143.      (win (create-window
  144.         :parent (screen-root screen)
  145.         :background black
  146.         :border white
  147.         :border-width 1
  148.         :colormap (screen-default-colormap screen)
  149.         :bit-gravity :center
  150.         :event-mask '(:exposure :key-press)
  151.         :x 20 :y 20
  152.         :width width :height height))
  153.      #+comment
  154.      (gc (create-gcontext
  155.            :drawable win
  156.            :background black
  157.            :foreground white)))
  158.     (initialize-extensions display)
  159.     
  160.     (map-window win)                ; Map the window
  161.     ;; Handle events
  162.     (unwind-protect
  163.     (dotimes (state 64)
  164.       (loop for code from (display-min-keycode display) to (display-max-keycode display) doing
  165.         (send-event win :key-press '(:key-press) :code code :state state
  166.             :window win :root (screen-root screen) :time 0
  167.             :x 1 :y 2 :root-x 10 :root-y 20 :same-screen-p t)
  168.         (event-case (display :force-output-p t :discard-p t)
  169.           (exposure  ;; Come here on exposure events
  170.         (window count)
  171.         (when (zerop count) ;; Ignore all but the last exposure event
  172.           (clear-area window))
  173.         nil)
  174.           (key-press (display code state)
  175.              (princ (keycode->character display code state))
  176.              t))))
  177.       (close-display display))))
  178.  
  179. (defun keysym-echo (host &optional keymap-p)
  180.   ;; Echo characters typed to a window
  181.   (let* ((display (open-display host))
  182.      (width 400)
  183.      (height 400)
  184.      (screen (display-default-screen display))
  185.      (black (screen-black-pixel screen))
  186.      (white (screen-white-pixel screen))
  187.      (win (create-window
  188.         :parent (screen-root screen)
  189.         :background black
  190.         :border white
  191.         :border-width 1
  192.         :colormap (screen-default-colormap screen)
  193.         :bit-gravity :center
  194.         :event-mask '(:exposure :key-press :keymap-state :enter-window)
  195.         :x 20 :y 20
  196.         :width width :height height))
  197.      (gc (create-gcontext
  198.            :drawable win
  199.            :background black
  200.            :foreground white)))
  201.     (initialize-extensions display)
  202.     
  203.     (map-window win)                ; Map the window
  204.     ;; Handle events
  205.     (unwind-protect
  206.     (event-case (display :force-output-p t :discard-p t)
  207.       (exposure  ;; Come here on exposure events
  208.         (window count)
  209.         (when (zerop count) ;; Ignore all but the last exposure event
  210.           (clear-area window)
  211.           (draw-glyphs window gc 10 10 "Press <escape> to exit"))
  212.         nil)
  213.       (key-press (display code state)
  214.              (let ((char (keycode->character display code state)))
  215.                (format t "~%Code: ~s State: ~s Char: ~s" code state char)
  216.                ;; (PRINC char) (PRINC " ")
  217.                (when keymap-p
  218.              (let ((keymap (query-keymap display)))
  219.                (unless (character-in-map-p display char keymap)
  220.                  (print "character-in-map-p failed")
  221.                  (print-keymap keymap))))
  222.                ;; (when (eql char #\0) (setq disp display) (break))
  223.                (eql char #\escape)))
  224.       (keymap-notify (keymap)
  225.         (print "Keymap-notify")  ;; we never get here.  Server bug?
  226.         (when (keysym-in-map-p display 65 keymap)
  227.           (print "Found A"))
  228.         (when (character-in-map-p display #\b keymap)
  229.           (print "Found B")))
  230.       (enter-notify (event-window) (format t "~%Enter ~s" event-window)))
  231.       (close-display display))))
  232.  
  233. (defun print-keymap (keymap)
  234.   (do ((j 32 (+ j 32))) ;; first 32 bits is for window
  235.       ((>= j 256))
  236.       (format t "~% ~3d: " j)
  237.       (do ((i j (1+ i)))
  238.       ((>= i (+ j 32)))
  239.     (when (zerop (logand i 7))
  240.       (princ " "))
  241.     (princ (aref keymap i)))))
  242.  
  243. (defun define-keysym-test (&key display printp
  244.                (modifiers (list (keysym :left-meta))) (mask :modifiers))
  245.   (let* ((keysym 067)
  246.      (args `(baz ,keysym :modifiers ,modifiers ,@(and mask `(:mask ,mask))))
  247.      (original (copy-tree (keysym-mappings keysym :display display))))
  248.     (when printp (print-keysym-mappings 67) (terpri))
  249.     (apply #'define-keysym args)
  250.     (when printp (print-keysym-mappings 67) (terpri))
  251.     (let ((is (keysym-mappings keysym :display display))
  252.       (should-be (append original (list args))))
  253.       (unless (equal is should-be)
  254.     (cerror "Ignore" "define-keysym error. ~%is:        ~s ~%Should be: ~s" is should-be)))
  255.     (apply #'undefine-keysym args)
  256.     (when printp (print-keysym-mappings 67) (terpri))
  257.     (let ((is (keysym-mappings keysym :display display)))
  258.       (unless (equal is original)
  259.     (cerror "Ignore" "undefine-keysym error. ~%is:        ~s ~%Should be: ~s" is original)))))
  260.  
  261. (define-keysym-test)
  262. (define-keysym-test :modifiers (make-state-mask :shift :lock))
  263. (define-keysym-test :modifiers (list :shift (keysym :left-meta) :control))
  264. (define-keysym-test :modifiers (make-state-mask :shift :lock) :mask nil)
  265.  
  266.